home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / gmain.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-01-30  |  23.3 KB  |  846 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #define GEN
  11.  
  12. #include <stdio.h>
  13. #include <ctype.h>
  14. #include "hdr.h"
  15. #include "vars.h"
  16. #include "gvars.h"
  17. #include "libhdr.h"
  18. #include "segment.h"
  19. #include "ifile.h"
  20. #include "dbxp.h"
  21. #include "packp.h"
  22. #include "g0ap.h"
  23. #include "dclmapp.h"
  24. #include "arithp.h"
  25. #include "axqrp.h"
  26. #include "axqwp.h"
  27. #include "genp.h"
  28. #include "segmentp.h"
  29. #include "expandp.h"
  30. #include "procp.h"
  31. #include "libp.h"
  32. #include "libfp.h"
  33. #include "librp.h"
  34. #include "libwp.h"
  35. #include "readp.h"
  36. #include "setp.h"
  37. #include "initp.h"
  38. #include "glibp.h"
  39. #include "gutilp.h"
  40. #include "miscp.h"
  41. #include "gmiscp.h"
  42. #include "gmainp.h"
  43.  
  44. static void fold_upper(char *);
  45. static void preface();
  46. static void exitf(int);
  47. static void init_gen();
  48. static void finit_gen();
  49.  
  50. IFILE    *AISFILE, *AXQFILE, *STUBFILE, *LIBFILE, *TREFILE;
  51. int list_unit_0 = 0; /* set by '0' option to list unit 0 structure */
  52. int peep_option = 1; /* on for peep_hole optimization */
  53.  
  54. extern Segment    CODE_SEGMENT, DATA_SEGMENT, DATA_SEGMENT_MAIN;
  55. extern Tuple units_in_compilation;
  56. extern Segment   VARIANT_TABLE, FIELD_TABLE ;
  57.  
  58. #ifdef DEBUG
  59. extern int zpadr_opt; /* not for EXPORT */
  60. #endif
  61.  
  62. char *lib_name;
  63.  
  64. /*
  65. #include "avl.c"
  66. */
  67.  
  68. main (int argc, char **argv)
  69. {
  70.     Node     node_new ();
  71.     int        c, i, n;
  72.     int        errflg = 0, nobuffer = 0, mflag = 0;
  73.     extern int  optind;
  74.     extern char *optarg;
  75.     char    *fname, *tfname;
  76.     char    *t_name;
  77.  
  78. /*
  79.     AVL_GET_DESC();
  80. _outtext(" Generating Code.");
  81. */
  82.  
  83.     AISFILE = (IFILE *)0;
  84.     AXQFILE = (IFILE *)0;
  85.     LIBFILE = (IFILE *)0;
  86.     STUBFILE = (IFILE *)0;
  87.     TREFILE = (IFILE *)0;
  88.  
  89.     MAINunit = "";
  90.     interface_files = "";
  91.  
  92.  
  93.     while ((c = getopt (argc, argv, "g:l:m:ni:")) != EOF)
  94.         /*    user:
  95.          *    g    debugging, followed by list of options:
  96.          *        0    show structure of unit 0
  97.          *        b    do not buffer standard output
  98.          *        e    flag signalling errors in the parsing phase
  99.          *        g    list generated code
  100.          *        l    show line numbers in generated code
  101.          *        p    compiling predef units
  102.          *        z    call trapini to initialize traps
  103.          *      i   to specify object files and librairies for pragma interface
  104.          *      l    using library
  105.          *        m    main unit name
  106.          *      n    new library
  107.          */
  108.         switch (c) {
  109.         case 'i':
  110.             interface_files = strjoin(interface_files, optarg);
  111.             interface_files = strjoin(interface_files, " ");
  112.             break;
  113.         case 'l': /* using existing library */
  114.             lib_name= emalloc((unsigned) strlen(optarg) + 1);
  115.             strcpy(lib_name, optarg);
  116.             break;
  117.         case 'm': /* specify main unit name */
  118.             MAINunit = malloc((unsigned) strlen(optarg)+1);
  119.             strcpy(MAINunit, optarg);
  120.             fold_upper(MAINunit);
  121.             break;
  122.         case 'n': /* indicates new library */
  123.             new_library = TRUE;
  124.             break;
  125.         case 'g': /* gen debug options */
  126.             n = strlen(optarg);
  127.             for (i = 0; i < n; i++) {
  128.                 switch((int)optarg[i]) {
  129. #ifdef DEBUG
  130.                 case 'a':
  131.                     zpadr_opt = 0; /* do not print addresses in zpadr */
  132.                     break;
  133. #endif
  134.                 case 'g':
  135.                     list_code++;
  136.                     break;
  137.                 case 'l':
  138.                     line_option++;
  139.                     break;
  140.                 case 'p': /* compiling predef units */
  141.                     printf("compiling predef\n");
  142.                     compiling_predef++ ;
  143.                     break;
  144. #ifdef DEBUG
  145.                 case 'b': /* do not buffer output */
  146.                     nobuffer++;
  147.                     break;
  148.                 case 'd': /* force debugging output */
  149.                     debug_flag++;
  150.                     break;
  151.                 case 'e':
  152.                     errors = TRUE;
  153.                     break;
  154.                 case 'o': /* disable optimization (peep) */
  155.                     peep_option = 0;
  156.                     break;
  157.                 case '0': /* read trace including unit 0 */
  158.                     list_unit_0++;
  159.                     break;
  160.                 case 'z': 
  161.                     trapini();
  162.                     break;
  163. #endif
  164.                 }
  165.             }
  166.             break;
  167.         case '?':
  168.             errflg++;
  169.         }
  170.     fname = (char *)0;
  171.     if (optind < argc)
  172.         fname = argv[optind];
  173.     if (fname == (char *)0) errflg++;
  174.     if (errflg) {
  175.         fprintf (stderr, "Usage: adagen -aAbglnmMnrstw file\n");
  176.         exitp(RC_ABORT);
  177.     }
  178.     tup_init(); /* initialize set and tuple procedures */
  179.     FILENAME =  (fname != (char *)0) ? strjoin(fname, "") : fname;
  180.  
  181.     if (compiling_predef) {
  182.         PREDEFNAME = "";
  183.     }
  184.     else
  185.         PREDEFNAME = predef_env();
  186.     if (nobuffer) {
  187.         setbuf (stdout, (char *) 0);    /* do not buffer output (for debug) */
  188.     }
  189.     rat_init(); /* initialize arithmetic and rational package*/
  190.     dstrings_init(2048, 256); /* initialize dstrings package */
  191.     init_sem();
  192.     DATA_SEGMENT_MAIN = main_data_segment();
  193.     aisunits_read = tup_new(0);
  194.     init_symbols = tup_exp(init_symbols, seq_symbol_n);
  195.     for (i = 1; i <= seq_symbol_n; i++)
  196.         init_symbols[i] = seq_symbol[i];
  197.     t_name = libset(lib_name);
  198.  
  199.     num_predef_units = (compiling_predef) ? 0 : init_predef();
  200.  
  201.     /*
  202.      * When the separate compilation facility is being used all references to
  203.      * AIS files will be made via the directory in LIBFILE. AISFILENAME is set
  204.      * to a number.
  205.      */
  206.     if (compiling_predef)
  207.         AISFILENAME = "0";
  208.     else if (new_library)
  209.         AISFILENAME = "1";
  210.     else
  211.         AISFILENAME = lib_aisname(); /* retrieve name from library */
  212.  
  213.     /* open the appropriate files using the suffix .axq for axq files and
  214.      * .trc for tree file. 
  215.      *
  216.      * Open MESSAGEFILE with suffixe ".msg" if a file name specified;
  217.      * otherwise, if a file name not required, and one is not given,
  218.      * used stderr.
  219.      */
  220.     AXQFILE  = ifopen(AISFILENAME, "axq", "w", 0);
  221.  
  222.     MSGFILE = (FILENAME != (char *) 0 ) ? efopenl(FILENAME, "msg", "a", "t") :
  223.       stderr;
  224.  
  225.     /* delete any existing st2 file for this AISFILENAME since it is now
  226.      * obsolete
  227.      */
  228.     ifdelete(strjoin(AISFILENAME, ".st2"));
  229.     /* unbuffer output for debugging purposes */
  230.     if (MSGFILE != stderr)
  231.         setbuf(MSGFILE, (char *) 0);
  232.     preface();
  233.  
  234.     /* Code formerly procedure finit() in init.c is now put here directly */
  235.     if (!errors) {
  236.         write_glib();
  237.         cleanup_files();
  238.     }
  239.  
  240.     if (compiling_predef) printf("Compilation of predef complete\n");
  241.     exitf(RC_SUCCESS);
  242. }
  243.  
  244. static void fold_upper(char *s)                                /*;fold_upper*/
  245. {
  246.     register char c;
  247.  
  248.     while (c = *s) {
  249.         if (islower(c)) *s = toupper(c);
  250.         s++;
  251.     }
  252. }
  253.  
  254. void fold_lower(char *s)                    /*;fold_lower*/
  255. {
  256.     register char c;
  257.  
  258.     while (c = *s) {
  259.         if (isupper(c)) *s = tolower(c);
  260.         s++;
  261.     }
  262. }
  263.  
  264. /* In the SETL version, preface has the global declarations of macros and
  265.  * variables. In the C version, the global variables are defined in gvars.ch
  266.  * (from which gvars.c and gvars.h are derived); macros and structure
  267.  * declarations are in ghdr.h.
  268.  * This file is retained for now to hold parts of code not moved to other
  269.  * files in the C version.
  270.  *
  271.  * pref2 - part 2 of preface: global variables, procedure declarations 
  272.  *
  273.  * Conventions for capitalization.
  274.  * The SETL version uses upper case names for some procedures, macros
  275.  * and global variables. Since case conventions are not enforced by the
  276.  * SETL compiler, there are cases where the same name is written more 
  277.  * than one way, differing only in case.
  278.  
  279.  * In C, we will use upper case for macro names, defined constants and most
  280.  * of the global variables, especially, the variables defined here. Where
  281.  * mixed-case usage is known to exist in the SETL version, such will be
  282.  * indicated by writine (mixed-case) after the variable name.
  283.  */
  284.  
  285. /* macros moved to hdr.c*/
  286.  
  287. static Set units_loaded;
  288.  
  289. static void preface()                                        /*;preface*/
  290. {
  291.     int    indx, last_index, i, rootseq, body_number;
  292.     Node    first_node, unit_node;
  293.     Tuple    aisread_tup, tup;
  294.     int unit_number_now;
  295.     struct unit *pUnit;
  296.     char    *spec_nam;
  297.     aisread_tup = tup_new(0);
  298.     initialize_1();
  299.     /* 1- Load PREDEF */
  300.  
  301.     TASKS_DECLARED = FALSE;
  302.     /* 2- Generate user program */
  303.  
  304.     initialize_2();
  305.  
  306.     if (gen_option) {
  307.         /* read all the units in file, aisunits_read is tuple of unit names of
  308.          * units found in file.
  309.          */
  310.         TREFILE  = ifopen(AISFILENAME, "aic", "r", 0);
  311.         last_index = last_comp_index(TREFILE);
  312.         indx = 0;
  313.         units_loaded = set_new(0);
  314.         for (indx = 1; indx <= last_index; indx++) {
  315.             unit_name = read_ais(AISFILENAME, TRUE, (char *) 0, indx, TRUE);
  316.             TREFILE  = ifopen(AISFILENAME, "trc", "r", 0);
  317.             load_tre(TREFILE, indx);
  318.             unit_number_now = unit_numbered(unit_name);
  319.             pUnit = pUnits[unit_number_now];
  320.             seq_node_n = pUnit->treInfo.nodeCount;
  321.             seq_node = tup_new(seq_node_n);
  322.  
  323.             /* set seq_symbol to corresponding values of symbols just read in */
  324.             seq_symbol_n = pUnit->aisInfo.numberSymbols;
  325.             tup = (Tuple) pUnit->aisInfo.symbols;
  326.             if ((int) seq_symbol[0] < seq_symbol_n)
  327.                 seq_symbol = tup_exp(seq_symbol, seq_symbol_n);
  328.             for (i = 1; i <= seq_symbol_n; i++)
  329.                 seq_symbol[i] = (char *) tup[i];
  330.  
  331.             rootseq = pUnit->treInfo.rootSeq;
  332.             first_node = (Node) getnodptr(rootseq, unit_number_now);
  333.             unit_node = N_AST2(first_node);
  334.             init_gen();
  335.             if (errors) {
  336.                 /* cannot retrieve message... already printed */
  337.                 user_info("Code generation for ");
  338.                 user_info(strjoin(formatted_name(unit_name), "abandonned"));
  339.             }
  340.             else {
  341.                 save_ada_line = ada_line;
  342.                 mint(unit_node);    /* remove qualify, name, parenthesis */
  343.                 expand(unit_node);
  344.                 if (errors) {
  345. #ifdef DEBUG
  346.                     to_list("Expander stopped");
  347. #endif
  348.                     exitf(RC_ERRORS);
  349.                 }
  350.                 ada_line = save_ada_line;
  351.                 if (N_KIND(unit_node) == as_separate)
  352.                     unit_node = N_AST2(unit_node);
  353.  
  354.                 switch (N_KIND(unit_node)) {
  355.                 case (as_subprogram_tr):
  356.                     if (is_generic(unit_name)) {
  357.                         /* Have the spec  designate this AXQfile */
  358.                         /* spec_nam = ['subprog spec'] + unit_name(2..); */
  359.                         spec_nam = strjoin("ss", unit_name_names(unit_name));
  360.                         /* not sure about use of _MEMORY 
  361.                          * LIB_UNIT(spec_nam)(2) = '_MEMORY';
  362.                          * LIB_UNIT(spec_nam)(3) = '_MEMORY';
  363.                          */
  364.                     }
  365.                     else {
  366.                         unit_subprog(unit_node);
  367.                     }
  368.                     break;
  369.                 case as_subprogram_decl_tr:
  370.                     unit_subprog_spec(unit_node);
  371.                     break;
  372.                 case(as_package_spec):
  373.                     unit_package_spec(unit_node);
  374.                     break;
  375.                 case(as_package_body):
  376.                     if (is_generic(unit_name)) {
  377.                         /* Have the spec  designate this AXQfile */
  378.                         /* spec_nam = ['spec'] + unit_name(2..); */
  379.                         spec_nam = strjoin("sp", unit_name_names(unit_name));
  380.                         /* not sure about use of _MEMORY 
  381.                          * LIB_UNIT(spec_nam)(2) = '_MEMORY';
  382.                          * LIB_UNIT(spec_nam)(3) = '_MEMORY';
  383.                          */
  384.                     }
  385.                     else {
  386.                         unit_package_body(unit_node);
  387.                     }
  388.                     break;
  389.                 case(as_generic_function):
  390.                 case(as_generic_procedure):
  391.                     /* late_instances(UNIT_NAME(2)) := {}; */
  392.                     late_instances = tup_with(late_instances,(char *)unit_name);
  393.                     /* allocate unit_number for body */
  394.                     /* TBSL: this should be done for spec ONLY */
  395.                     body_number =
  396.                       unit_number(strjoin("su", unit_name_names(unit_name)));
  397.                     pUnits[body_number]->libInfo.obsolete = string_ds;
  398.                     break;
  399.                 case(as_generic_package):
  400.                     /* late_instances(UNIT_NAME(2)) := {}; */
  401.                     late_instances = tup_with(late_instances,(char *)unit_name);
  402.                     /* allocate unit_number for body */
  403.                     /* TBSL: this should be done for spec ONLY */
  404.                     body_number =
  405.                       unit_number(strjoin("bo", unit_name_names(unit_name)));
  406.                     pUnits[body_number]->libInfo.obsolete = string_ds;
  407.                     break;
  408.                 case(as_procedure_instance):
  409.                 case(as_function_instance):
  410.                 case(as_package_instance):
  411.                     compiler_error("Late instantiations not implemented");
  412.                     break;
  413.                 default:
  414.                     compiler_error_k("Unexpected unit: ", unit_node);
  415.                 }
  416.                 finit_gen();
  417.                 tup_free(seq_node);
  418.                 if (errors) {
  419. #ifdef DEBUG
  420.                     to_list("Code generation stopped");
  421. #endif
  422.                     exitf(RC_ERRORS);
  423.                 }
  424.                 store_axq(AXQFILE, unit_number_now);
  425.             }
  426.         } /* for */
  427.     }
  428. }
  429.  
  430. static void exitf(int status)                                        /*;exitf*/
  431. {
  432.     /* exit after closing any open files */
  433.     ifoclose(AXQFILE);
  434.     ifoclose(LIBFILE);
  435.     ifoclose(STUBFILE);
  436.     exitp(status);
  437. }
  438.  
  439. void user_error(char *reason)                                    /*;user_error*/
  440. {
  441.     errors++;
  442.     list_hdr(ERR_SEMANTIC);
  443.     fprintf(MSGFILE, " %s\n", reason);
  444. }
  445.  
  446. void user_info(char *line)                                        /*;user_info*/
  447. {
  448.     list_hdr(INFORMATION);
  449.     fprintf(MSGFILE, "%s\n", line);
  450. }
  451.  
  452. static void init_gen()                                            /*;init_gen*/
  453. {
  454.     /*
  455.      *  Initialization of global variables to be performed for each
  456.      *  compilation unit
  457.      */
  458.  
  459.     Tuple    tup;
  460.     struct unit *pUnit;
  461.     int        si, i, unum, u_new;
  462.     int in_names, ii;
  463.     char *tstr;
  464.     char    *unam, *unam_type;
  465.     Set        units_to_load;
  466.     Forset    fs1;
  467.     Fortup    ft1;
  468.     Symbol    unit_unam;
  469.     Tuple    s_info, decscopes, decmaps;
  470.     Unitdecl    ud;
  471.     Stubenv    ev;
  472.  
  473.     if (EMAP != (Tuple)0) tup_free(EMAP);
  474.     EMAP = tup_new(0);
  475. #ifdef TBSN
  476.     /* STATIC_DEPTH POSITION and PATCHES are part of EMAP in C version */
  477.     STATIC_DEPTH         = {
  478.     };
  479.     POSITION         = {
  480.     };
  481.     PATCHES         = {
  482.     };
  483. #endif
  484.     /* PATCH_SET is defined by never used
  485.      *  PATCH_SET         = tup_new(0);
  486.      */
  487.     PARAMETER_SET     = tup_new(0);
  488.     RELAY_SET         = tup_new(0);
  489.     SPECS_DECLARED    =    0;
  490.     SUBPROG_PATCH     = tup_new(0);
  491.     SUBPROG_SPECS     = tup_new(0);
  492.     GENERATED_OBJECTS = tup_new(0);
  493.     DANGLING_RELAY_SETS         = tup_new(0);
  494.     /* Initialize slots correspondint to  SETL OWNED_SLOTS and BORROWED_SLOTS */
  495.     /* Assume that unit_number_now has unit_number corresponding to unit_name */
  496.     /* Set initial unit_slots map to null value */
  497.     /* assume unit_number_now gives curent unit number; the correct
  498.      * assignment of this may best be done elsewhere
  499.      *    ds  6-20-85
  500.      */
  501.     unit_number_now = unit_number(unit_name);
  502.     tup = tup_new(5);
  503.     for (i = 1; i <= 5; i++)
  504.         tup[i] = (char *) tup_new(0);
  505.     unit_slots_put(unit_number_now, tup);
  506.  
  507.     /* remove any slots belonging to this unit from previous compilation */
  508.     remove_slots(CODE_SLOTS, unit_number_now);
  509.     remove_slots(DATA_SLOTS, unit_number_now);
  510.  
  511.     /* remove any pragma interface belonging to this unit from previous
  512.      * compilation
  513.      */
  514.     remove_interface(interfaced_procedures, unit_number_now);
  515.  
  516.     /*  Initialization of global variables */
  517.  
  518. #ifdef TBSN
  519.     NATURE    = INIT_NATURE;
  520.     TYPE_OF   = INIT_TYPE_OF;
  521.     SIGNATURE = INIT_SIGNATURE;
  522.     ALIAS     = INIT_ALIAS;
  523.     TYPE_SIZE = INIT_TYPE_SIZE;
  524.     MISC         = INIT_MISC;
  525.     INIT_PROC = {
  526.     };
  527.     CONSTANT_MAP      = {
  528.     };
  529.     REFERENCE_MAP  = INIT_REFERENCE_MAP;
  530. #endif
  531.     STUBS_IN_UNIT  = FALSE;
  532.     errors = FALSE;
  533.     TASKS_DECLARED = FALSE;
  534.     /*
  535.      * Load necessary (direct and indirect) units BEFORE this one, in order for 
  536.      * body's defns to override spec's. A 'subprog' is loaded only if there 
  537.      * is no corresponding 'subprog spec'. Bodies can be here because of pragma 
  538.      * ELABORATE, and need not be loaded. On the other hand, a body that is an 
  539.      * ancestor of the curr unit, or a generic body, needed for instantiation, 
  540.      * is loaded.
  541.      */
  542.     ud = unit_decl_get(unit_name);
  543.     unit_unam = ud->ud_unam;
  544.     if (NATURE(unit_unam) != na_generic_procedure 
  545.       && NATURE(unit_unam) != na_generic_function
  546.       && NATURE(unit_unam) != na_generic_package) {
  547.         /* do not bring in spec (or anything) for generic unit */
  548.         /* units_to_load = PRE_COMP(unit_name); */
  549.         pUnit = pUnits[unit_number_now];
  550.         units_to_load = set_copy((Set) pUnit->aisInfo.preComp);
  551.         while (set_size(units_to_load) != 0) {
  552. #ifdef TRACE
  553.             if (debug_flag)
  554.                 gen_trace_units("UNITS_TO_LOAD", units_to_load);
  555. #endif
  556.             /* unam from units_to_load; */
  557.             unum = (int) set_from(units_to_load);
  558.             unam = pUnits[unum]->name;
  559.             unam_type = unit_name_type(unam);
  560.             in_names = FALSE;
  561.             tstr = strjoin("sp", unit_name_name(unam));
  562.             for (ii = 1; ii <= unit_numbers; ii++) {
  563.                 if (streq(tstr, pUnits[ii]->name)) {
  564.                     in_names = TRUE;
  565.                     break;
  566.                 }
  567.             }
  568.             if (((streq(unam_type, "sp") || streq(unam_type, "ss"))
  569.               || (streq(unam_type, "su") && !in_names))
  570.               || is_ancestor(unam) || is_generic(unam)) {
  571.                 if (!set_mem((char *) unum, units_loaded)) {
  572.                     errors = errors || !load_unit(unam, TRUE);
  573.                     units_loaded = set_with(units_loaded, (char *) unum);
  574.                 }
  575.                 ud = unit_decl_get(unam) ;
  576.                 private_install(ud->ud_unam) ;
  577.                 /* units_to_load += PRE_COMP(unam) ? {}; --May be om if error */
  578.                 pUnit = pUnits[unum];
  579.                 if ((Set)pUnit->aisInfo.preComp != (Set)0) {
  580.                     /* add any units now yet seen to list of those to be loaded,
  581.                      * but load no unit more than once.
  582.                      */
  583.                     FORSET(u_new = (int), (Set)pUnit->aisInfo.preComp, fs1);
  584.                         if (!set_mem((char *) u_new, units_loaded))
  585.                             units_to_load =
  586.                               set_with(units_to_load, (char *) u_new);
  587.                     ENDFORSET(fs1);
  588.                 }
  589.                 if (is_generic(unam)
  590.                   && (streq(unam_type, "ss")||streq(unam_type, "sp"))) {
  591.                     char *fname, *body_name;
  592.                     if (streq(unam_type, "ss"))
  593.                         body_name = strjoin("su", unit_name_name(unam));
  594.                     else 
  595.                         body_name = strjoin("bo", unit_name_name(unam));
  596.                     fname = lib_unit_get(body_name) ;
  597.                     if (fname != (char *)0) {
  598.                         /* body already seen */
  599.                         load_unit(body_name, TRUE);
  600.                     }
  601.                     else {
  602.                         /* try to read from current file */
  603.                         read_ais(AISFILENAME, TRUE, body_name, 0, TRUE);
  604.                     }
  605.                 }
  606.                 /* Temp kludge until FE removes self references: (generics) */
  607.                 units_to_load = set_less(units_to_load, (char *) unum);
  608.             }
  609.         } /* end while */
  610.         set_free(units_to_load);
  611.     }
  612.  
  613.     if (errors) return;
  614. #ifdef IGNORE
  615.     ud = unit_decl_get(unit_name);
  616.     /* [unit_unam, s_info, decls] = UNIT_DECL(unit_name); */
  617.     unit_unam = ud->ud_unam;
  618. #endif
  619.     s_info = ud->ud_symbols;
  620.     decscopes = ud->ud_decscopes;
  621.     decmaps = ud->ud_decmaps;
  622.     /* TBSL does the info from decscopes and decmaps need to be restored 
  623.      * or is the info restored by symtab_restore since 
  624.      * stored with the symbols.
  625.      * DECLARED  += decls; 
  626.      * SYMBTABQ restore 
  627.      */
  628.     symtab_restore(s_info);
  629.  
  630.     if (is_subunit(unit_name)
  631.       && (NATURE(unit_unam) != na_generic_procedure
  632.       && NATURE(unit_unam) != na_generic_function)) {
  633.         /* retrieve stub environment */
  634.  
  635.         /* [-, -, decl,-,-,-,-,-,-,-,package_info] = STUB_ENV(unit_name);
  636.          * loop forall decls = decl(os) do
  637.          *   loop forall [-, unam, entry] in decls do
  638.          *      SYMBTABF(unam) = entry;
  639.          *   end loop;
  640.          * end loop;
  641.          */
  642.         if (!streq(lib_stub_get(unit_name), AISFILENAME))
  643.             read_stub(lib_stub_get(unit_name), unit_name, "st2");
  644.         si = stub_numbered(unit_name);
  645.         tup = (Tuple) stub_info[si];
  646.         ev = (Stubenv) tup[2];
  647.         update_stub(ev);
  648.         s_info = ev->ev_open_decls;
  649.         symtab_restore(s_info);
  650.     }
  651.     DATA_SEGMENT = segment_new(SEGMENT_KIND_DATA, 0);
  652.     CODE_SEGMENT = segment_new(SEGMENT_KIND_CODE, 0);
  653.  
  654.     /* If the unit was previously compiled remove possible obselete stubs of it
  655.      * from the library.
  656.      */
  657.     FORTUP(unam = (char *), lib_stub, ft1);
  658.         if (stub_parent_get(unam) ==  unit_number_now)
  659.             lib_stub_put(unam, (char *)0);
  660.     ENDFORTUP(ft1);
  661.  
  662. #ifdef MACHINE_CODE
  663.     if (list_code) {
  664.         to_gen(" ");
  665.         to_gen(" ");
  666.         to_gen_unam("============== UNIT : ", formatted_name(unit_name),
  667.             " ==============" );
  668.     }
  669. #endif
  670. }
  671.  
  672. static void finit_gen()                                            /*;finit_gen*/
  673. {
  674.     /*
  675.      * Clean up symbol table, and write it back to file, together with
  676.      * the code slots and the data_segment
  677.      */
  678.  
  679.     int            unum;
  680.     Set            precedes, suppressed_units;
  681.     Forset        fs1;
  682.     Fortup        ft1;
  683.     struct unit *pUnit;
  684.     Tuple        symbols, new_comp_table;
  685.     Symbol        package_name;
  686.     Unitdecl        ud;
  687.     char msg[80];
  688.     int i;
  689.  
  690. #ifdef MACHINE_CODE
  691.     if (list_code) {
  692.         to_gen(" ");
  693.         to_gen_unam("============== end of " , formatted_name(unit_name),
  694.             " ==============" );
  695.         to_gen(" ");
  696.         to_gen("--- Global reference map :");
  697.         print_ref_map_global();
  698.     }
  699. #endif
  700.     /* If it is a package, swap private and full declarations 
  701.      *
  702.      * if UNIT_NAME(1) in {'spec', 'body'} then
  703.      *   package_name = UNIT_NAME(2);
  704.      *   temp_symbtab = {};
  705.      *   loop forall [unam, entry] in OVERLOADS(package_name) ? {} do
  706.      *       temp_symbtab(unam) = SYMBTABF(unam);
  707.      *       SYMBTABF(unam) = entry;
  708.      *    end loop;
  709.      *    OVERLOADS(package_name) = temp_symbtab;
  710.      *  end if;
  711.      */
  712.     ud = unit_decl_get(unit_name);
  713.     if (!is_generic(unit_name) && (streq(unit_name_type(unit_name), "sp")
  714.       || streq(unit_name_type(unit_name), "bo"))) {
  715.         package_name =  ud->ud_unam;
  716.         private_exchange(package_name) ;
  717.     }
  718.  
  719.     /* Add Code generator infos to unit symbol table 
  720.      *  [unit_unam, s_info, decls, old_vis, notvis, context, unit_nodes] =
  721.      *     UNIT_DECL(unit_name);
  722.      *
  723.      * loop forall unam in domain s_info do
  724.      * s_info(unam) = SYMBTABFQ(unam);
  725.      * end loop;
  726.      *
  727.      * Add infos for internally generated objects 
  728.      *
  729.      * loop forall unam in GENERATED_OBJECTS do
  730.      *  s_info(unam) = SYMBTABFQ(unam);
  731.      * end loop;
  732.      *
  733.      * UNIT_DECL(unit_name) =
  734.      *    [unit_unam, s_info, decls, old_vis, notvis, context, unit_nodes];
  735.      */
  736.  
  737.     symbols = ud->ud_symbols;
  738.     symbols = tup_add(symbols, GENERATED_OBJECTS);
  739.     ud->ud_symbols = symbols;
  740.  
  741.     if (!is_generic(unit_name)) {
  742.         /* DATA_SEGMENT_MAP(CURRENT_DATA_SEGMENT) = DATA_SEGMENT;*/
  743.         DATA_SEGMENT_MAP = segment_map_put(DATA_SEGMENT_MAP,
  744.           CURRENT_DATA_SEGMENT, DATA_SEGMENT);
  745. #ifdef MACHINE_CODE
  746.         if (list_code) print_data_segment();
  747. #endif
  748.     }
  749.     if (errors) {
  750.         sprintf(msg,"\n%d Error%s detected. ", errors, (errors > 1) ? "s" : "");
  751.         _outtext(msg);
  752.         _outtext("\nPress any key to continue... ");
  753.         i = getch(); if (i == 0) i = getch();
  754. /*
  755.         to_gen_unam("Error(s) were detected in ",
  756.           formatted_name(unit_name), " unit not inserted in library");
  757. */
  758.     }
  759. #ifdef TBSL
  760.     else {
  761.         if (is_generic(unit_name)) {
  762.             /* Free slots allocated by INIT_GEN */
  763.             OWNED_SLOTS(unit_name) = [ {}, {}, {}];
  764.         }
  765. #endif
  766.     /*  Suppress dependant units and collect their slots; update library */
  767.     /*    Report all units which are removed */
  768.     if (!compiling_predef)
  769.         suppressed_units = remove_same_name(unit_name);
  770.     else
  771.         suppressed_units = set_new(0);
  772. #ifdef TBSL
  773.         set_ds = set_cs :
  774.         = set_es :
  775.           = {
  776.           };
  777. #endif
  778.     if (set_size(suppressed_units) != 0) {
  779.         to_list( strjoin(
  780.           "Following unit(s) have been deleted by compilation of ",
  781.           formatted_name(unit_name) ) );
  782.         FORSET(unum = (int), suppressed_units, fs1);
  783.             to_list(formatted_name(pUnits[unum]->name));
  784.  
  785.             /* LIB_UNIT(unam) = OM; */
  786.             lib_unit_put(pUnits[unum]->name, (char *)0);
  787.             precedes_map_put(pUnits[unum]->name, set_new(0));
  788.             /* remove slots belonging to obselete units */
  789.             remove_slots(CODE_SLOTS, unum);
  790.             remove_slots(DATA_SLOTS, unum);
  791.             /* remove pragma interface belonging to obsolete units */
  792.             remove_interface(interfaced_procedures, unum);
  793.         ENDFORSET(fs1);
  794.         to_list(" ");
  795.     }
  796. #ifdef TBSL
  797.     /* Warning: user units may have same name as a predefined one */
  798.     PREDEF_UNITS = [[unam in PREDEF_UNITS(1)
  799.           | unam notin suppressed_units with unit_name],
  800.            PREDEF_UNITS(2) - suppressed_units less unit_name
  801.           ];
  802.  
  803.     DATA_SLOTS     = { [x, y]: 
  804.         [x, y] in DATA_SLOTS
  805.             |   y notin set_ds
  806.             or y in OWNED_SLOTS(unit_name)(1)        };
  807.     CODE_SLOTS     = { [x, y]: 
  808.         [x, y] in CODE_SLOTS
  809.             |   y notin set_cs
  810.             or y in OWNED_SLOTS(unit_name)(2)        };
  811.     EXCEPTION_SLOTS= { [x, y]: 
  812.         [x, y] in EXCEPTION_SLOTS
  813.             |   y notin set_es
  814.             or y in OWNED_SLOTS(unit_name)(3)        };
  815.     /* less unit_name: temporary kludge FE. */
  816. #endif
  817.     /* precedes{unit_name} = PRE_COMP(unit_name) less unit_name; */
  818.     pUnit = pUnits[unit_number_now];
  819.     precedes = set_copy((Set)pUnit->aisInfo.preComp);
  820.     precedes_map_put(unit_name, precedes);
  821.     /* compilation_table = [name: name in compilation_table
  822.      *              | name notin suppressed_units]    with unit_name;
  823.      */
  824.     new_comp_table = tup_new(0);
  825.     FORTUP(unum = (int), compilation_table, ft1);
  826.         if (!set_mem((char *)unum,
  827.            suppressed_units) && unum != unit_number_now)
  828.             new_comp_table = tup_with(new_comp_table, (char *) unum);
  829.     ENDFORTUP(ft1);
  830.     compilation_table = tup_with(new_comp_table, (char *) unit_number_now);
  831.     lib_unit_put(unit_name, AISFILENAME);
  832.     /* if the same compilation unit appears in the same compilation (file)
  833.      * more than once, disable the code for all but the last in the axqfile
  834.      * so that it is not read.
  835.      */
  836.     if (tup_mem((char *)unit_number_now, units_in_compilation))
  837.         overwrite_unit_name(unit_name);
  838.  
  839.     units_in_compilation = 
  840.       tup_with(units_in_compilation, (char *)unit_number_now);
  841.  
  842.     pUnit->libInfo.currCodeSeg = (char *) CURRENT_CODE_SEGMENT;
  843.     if (STUBS_IN_UNIT)
  844.         pUnit->libInfo.localRefMap = (char *) tup_copy(LOCAL_REFERENCE_MAP);
  845. }
  846.